home *** CD-ROM | disk | FTP | other *** search
/ Aminet 28 / Aminet 28 (1998)(GTI - Schatztruhe)[!][Dec 1998].iso / Aminet / dev / lang / fpcsrc.lha / fpc / compiler / ptconst.pas < prev    next >
Pascal/Delphi Source File  |  1998-09-24  |  21KB  |  527 lines
  1. {
  2.     $Id: ptconst.pas,v 1.1.1.1.2.1 1998/07/29 12:31:41 carl Exp $
  3.     Copyright (c) 1998 by Florian Klaempfl
  4.  
  5.     Reads typed constants
  6.  
  7.     This program is free software; you can redistribute it and/or modify
  8.     it under the terms of the GNU General Public License as published by
  9.     the Free Software Foundation; either version 2 of the License, or
  10.     (at your option) any later version.
  11.  
  12.     This program is distributed in the hope that it will be useful,
  13.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15.     GNU General Public License for more details.
  16.  
  17.     You should have received a copy of the GNU General Public License
  18.     along with this program; if not, write to the Free Software
  19.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  ****************************************************************************
  22. }
  23. unit ptconst;
  24.  
  25.   interface
  26.  
  27.    uses symtable;
  28.  
  29.     { this procedure reads typed constants }
  30.     procedure readtypedconst(def : pdef);
  31.  
  32.   implementation
  33.  
  34.     uses
  35.        cobjects,globals,scanner,aasm,tree,pass_1,
  36.        hcodegen,types,verbose
  37.        { parser specific stuff }
  38.        ,pbase,pexpr
  39.        { processor specific stuff }
  40. {$ifdef i386}
  41.        ,i386
  42. {$endif}
  43. {$ifdef m68k}
  44.        ,m68k
  45. {$endif}
  46.        ;
  47.  
  48.     { this procedure reads typed constants }
  49.     procedure readtypedconst(def : pdef);
  50.  
  51.       var
  52.          j: integer;
  53.          p : ptree;
  54.          i,l : longint;
  55.          ll : plabel;
  56.          s : string;
  57.          ca : pchar;
  58.          aktpos : longint;
  59.          pd : pprocdef;
  60.          hp1,hp2 : pdefcoll;
  61.  
  62.          value : bestreal;
  63.          {problem with fldt !!
  64.          anyway .valued is not extended !!
  65.          value : double; }
  66.  
  67.       procedure check_range;
  68.  
  69.         begin
  70.            if ((p^.value>porddef(def)^.bis) or
  71.                (p^.value<porddef(def)^.von)) then
  72.              Message(parser_e_range_check_error);
  73.         end;
  74.  
  75. {$R-}  {Range check creates problem with init_8bit(-1) !!}
  76.       begin
  77.          j:=0;
  78.          case def^.deftype of
  79.             orddef:
  80.               begin
  81.                  p:=expr;
  82.                  do_firstpass(p);
  83.                  case porddef(def)^.typ of
  84.                     s8bit,
  85.                     u8bit : begin
  86.                                if not is_constintnode(p) then
  87.                                { is't an int expected }
  88.                                  Message(cg_e_illegal_expression)
  89.                                else
  90.                                  begin
  91.                                     datasegment^.concat(new(pai_const,init_8bit(p^.value)));
  92.                                     check_range;
  93.                                  end;
  94.                             end;
  95.                     s32bit : begin
  96.                                 if not is_constintnode(p) then
  97.                                   Message(cg_e_illegal_expression)
  98.                                 else
  99.                                   begin
  100.                                      datasegment^.concat(new(pai_const,init_32bit(p^.value)));
  101.                                      check_range;
  102.                                   end;
  103.                             end;
  104.                     u32bit : begin
  105.                                 if not is_constintnode(p) then
  106.                                   Message(cg_e_illegal_expression)
  107.                                 else
  108.                                    datasegment^.concat(new(pai_const,init_32bit(p^.value)));
  109.                              end;
  110.                     bool8bit : begin
  111.                                   if not is_constboolnode(p) then
  112.                                     Message(cg_e_illegal_expression);
  113.                                   datasegment^.concat(new(pai_const,init_8bit(p^.value)));
  114.                                end;
  115.                     uchar : begin
  116.                                 if not is_constcharnode(p) then
  117.                                   Message(cg_e_illegal_expression);
  118.                                 datasegment^.concat(new(pai_const,init_8bit(p^.value)));
  119.                             end;
  120.                     u16bit,
  121.                     s16bit : begin
  122.                                 if not is_constintnode(p) then
  123.                                   Message(cg_e_illegal_expression);
  124.                                 datasegment^.concat(new(pai_const,init_16bit(p^.value)));
  125.                                 check_range;
  126.                             end;
  127.                  end;
  128.                  disposetree(p);
  129.               end;
  130.          floatdef:
  131.            begin
  132.               p:=expr;
  133.               do_firstpass(p);
  134.               if is_constrealnode(p) then
  135.                 value:=p^.valued
  136.               else if is_constintnode(p) then
  137.                 value:=p^.value
  138.               else
  139.                 Message(cg_e_illegal_expression);
  140.  
  141.               case pfloatdef(def)^.typ of
  142.                  s64real : datasegment^.concat(new(pai_double,init(value)));
  143.                  s32real : datasegment^.concat(new(pai_single,init(value)));
  144.                  s80real : datasegment^.concat(new(pai_extended,init(value)));
  145.                  s64bit  : datasegment^.concat(new(pai_comp,init(value)));
  146.                  f32bit : datasegment^.concat(new(pai_const,init_32bit(trunc(value*65536))));
  147.               else internalerror(18);
  148.               end;
  149.               disposetree(p);
  150.            end;
  151.          pointerdef:
  152.            begin
  153.               p:=expr;
  154.               do_firstpass(p);
  155.               { nil pointer ? }
  156.               if p^.treetype=niln then
  157.                 datasegment^.concat(new(pai_const,init_32bit(0)))
  158.               { maybe pchar ? }
  159.               else if (ppointerdef(def)^.definition^.deftype=orddef) and
  160.                    (porddef(ppointerdef(def)^.definition)^.typ=uchar) then
  161.                 begin
  162.                    getlabel(ll);
  163.                    { insert string at the begin }
  164.                    if p^.treetype=stringconstn then
  165.                      generate_ascii_insert((p^.values^)+#0)
  166.                    else if is_constcharnode(p) then
  167.                      datasegment^.insert(new(pai_string,init(char(byte(p^.value))+#0)))
  168.                    else Message(cg_e_illegal_expression);
  169.                    datasegment^.insert(new(pai_label,init(ll)));
  170.                    { insert label }
  171.                    datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str(ll)))));
  172.                 end
  173.               else if p^.treetype=addrn then
  174.                 begin
  175.                    if (is_equal(ppointerdef(p^.resulttype)^.definition,ppointerdef(def)^.definition) or
  176.                       (is_equal(ppointerdef(p^.resulttype)^.definition,voiddef)) or
  177.                       (is_equal(ppointerdef(def)^.definition,voiddef))) and
  178.                       (p^.left^.treetype = loadn) then
  179.                      begin
  180.                         datasegment^.concat(new(pai_const,init_symbol(
  181.                           strpnew(p^.left^.symtableentry^.mangledname))));
  182.                         if p^.left^.symtableentry^.owner^.symtabletype=unitsymtable then
  183.                           concat_external(p^.left^.symtableentry^.mangledname,EXT_NEAR);
  184.                      end
  185.                    else
  186.                      Message(cg_e_illegal_expression);
  187.                 end
  188.               else
  189.               { allow typeof(Object type)}
  190.                 if (p^.treetype=inlinen) and
  191.                    (p^.inlinenumber=in_typeof_x) then
  192.                   if (p^.left^.treetype=typen) then
  193.                     begin
  194.                        datasegment^.concat(new(pai_const,init_symbol(
  195.                          strpnew(pobjectdef(p^.left^.resulttype)^.vmt_mangledname))));
  196.                        if pobjectdef(p^.left^.resulttype)^.owner^.symtabletype=unitsymtable then
  197.                           concat_external(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,EXT_NEAR);
  198.                     end
  199.                   else
  200.                     begin
  201.                        Message(cg_e_illegal_expression);
  202.                     end
  203.                 else
  204.                   Message(cg_e_illegal_expression);
  205.               disposetree(p);
  206.